{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Concepts.Algos
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Alogorithms for Formal Concept Analysis.
-- 
--------------------------------------------------------------------------------

module Concepts.Algos
  ( 

    Objects
  , Attributes

  , objects
  , attributes

  , Relation
  , Concept(..)
  , Context(..)
  , intent
  , extent

  , neighbors
  , lattice

  )  where


import Data.Monoid 
import qualified Data.Set as S
import Data.Set ( (\\) )

import Prelude hiding ( min ) 

type Objects a = S.Set a

type Attributes a = S.Set a

type Relation a b = a -> b -> Bool

objects :: Ord a => [a] -> Objects a
objects = S.fromList

attributes :: Ord a => [a] -> Attributes a
attributes = S.fromList

data Concept g m = Concept 
    { con_objects       :: Objects g
    , con_attributes    :: Attributes m
    }
  deriving (Eq,Show,Ord)

data Context g m = Context 
    { ctx_objects       :: Objects g
    , ctx_attributes    :: Attributes m
    , ctx_relation      :: Relation g m
    }


extent :: Concept g m -> Objects g
extent = con_objects

intent :: Concept g m -> Attributes m
intent = con_attributes


instance (Ord g, Ord m) => Monoid (Concept g m) where
  mempty = Concept mempty mempty
  Concept g1 m1 `mappend` Concept g2 m2 = 
      Concept (g1 `S.union` g2) (m1 `S.union` m2)

type H a = [a] -> [a] 

emptyH :: H a
emptyH = id

snocH :: H a -> a -> H a
snocH f a = f . (a:)

unH :: H a -> [a]
unH f = f []

neighbors :: (Ord g, Ord m) 
          => Concept g m -> Context g m -> [Concept g m]
neighbors (Concept bigG _) ctx@(Context curlyG _ _) = 
    let min         = curlyG \\ bigG
        nehbors     = emptyH
    in work min nehbors (S.toList min)
  where
    work _   nehbors []     = unH $ nehbors
    work min nehbors (g:gs) = 
        let m1 = oprime ctx (S.insert g bigG)
            g1 = aprime ctx m1
            temp = g1 \\ bigG \\ S.singleton g
        in if (S.null $ min `S.intersection` temp)
             then work min (nehbors `snocH` Concept g1 m1) gs
             else work (S.delete g min) nehbors gs



-- 2 versions of prime 
-- oprime derives attributes (m) from objects (g)
-- aprime derives objects (g) from attributes (m)

oprime :: Ord m => Context g m -> Objects g -> Attributes m
oprime (Context _ attrs rel) objs =
    S.filter (\a -> setall (\o -> o `rel` a) objs) attrs


aprime :: Ord g => Context g m -> Attributes m -> Objects g
aprime (Context objs _ rel) attrs = 
    S.filter (\o -> setall (\a -> o `rel` a) attrs) objs
    
-- What are the prime (derivation) operators doing?
--
-- Clearly @deriv@ cannot have the type sig below as it must 
-- manufacture attributes from objects...
--


setall :: (a -> Bool) -> S.Set a -> Bool
setall f s = let (_,zero) = S.partition f s in S.null zero


-- | Acknowledgment - I had to work through Joost Visser\'s
-- Formal Concept Analysis code (from the PURe groups svn 
-- repository) to derive this implementation of Christian 
-- Lindig\'s LATTICE algorithm.
--
lattice :: (Ord g, Ord m) => Context g m -> [(Concept g m, Concept g m)]
lattice ctx = 
    let zeroP  = oprime ctx mempty
        zeroPP = aprime ctx zeroP
        c0     = Concept zeroPP zeroP
    in work [c0] [] S.empty
  where
    work []                       _    bigL = S.toList bigL
    work (c@(Concept ext _):rest) done bigL 
        | ext `elem` done                   = work rest done bigL
        | otherwise                         = 
            let ns    = neighbors c ctx
                bigL' = S.fromList (map (\c' -> (c',c)) ns) `S.union` bigL
            in work (ns ++ rest) (ext:done) bigL'